home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / WORDMISC / BANNER.LZH / FONTCODE.BAS < prev    next >
BASIC Source File  |  1986-09-06  |  22KB  |  1,055 lines
  1. 'FONTCODE.BAS Version 2.1 (C) Copyright 1985, 1986 by Merlin R. Null
  2. '9/6/86
  3. 'Requires Microsoft,s QuickBASIC version 2.0 to compile and MASM for
  4. 'assembly of the fast video routines.  Creates (or decodes) data files
  5. 'for use with the FONTSY banner printer from multiple source files
  6. 'created with a word processor.  This program may not be sold separately
  7. 'or as part of any collection of programs or used as an inducement to
  8. 'buy any other product or program without the permission of the author:
  9. 'Merlin R. Null, P.O. Box 9422, N. Hollywood, CA 91609, (818) 762-1429
  10.  
  11.       DEFINT A-Z
  12.       DIM CharCode$(95),Lin$(200),Lin90$(200)
  13.       ON ERROR GOTO ErrorHandle
  14.       COLOR 11,0
  15.       'Check command tail for font name
  16.       IF LEN(COMMAND$)=0 THEN
  17.     Font$="<none>"
  18.       ELSE
  19.     NEWFONT$=COMMAND$
  20.     CALL    MenuScreen
  21.     GOTO ReadFont
  22.       END IF
  23. MainMenu:
  24.       Wdth$="Single"
  25.       WColor=11
  26.       WMult=1
  27.       Hght$="Single"
  28.       HtColor=11
  29.       HtMult=1
  30.       HtDiv=1
  31.       COLOR HtColor,0
  32.       CALL    MenuScreen
  33.       LOCATE 4,23
  34.       PRINT Font$
  35.       LOCATE 6,9
  36.       PRINT Title$
  37.       LOCATE 7,9
  38.       PRINT Comment$
  39.       IF Font$="<none>" THEN
  40.     CALL    Description
  41.       ELSE
  42.     CALL    AvailChars
  43.     IF FontContent$="" THEN
  44.       LOCATE 11,37
  45.       PRINT"<none>"
  46.     ELSE
  47.       LOCATE 10,1
  48.       FOR I=1 TO 133 STEP 66
  49.         IF LEN(FontContent$)>I THEN
  50.           PRINT TAB(8) MID$(FontContent$,I,65)
  51.         END IF
  52.       NEXT
  53.     END IF
  54.       END IF
  55.       IF NotSaved THEN
  56.     LOCATE 20,36
  57.     PRINT"- Not Saved"
  58.       END IF
  59.       LOCATE 24,34,1
  60. GetOption:
  61.       Opt$=INPUT$(1)
  62.       NotUsed=0
  63.       NumChars=0
  64.  
  65.       IF Opt$="1" THEN    'Option 1. Load an existing font (encoded)
  66.     CALL    Opt1Prompt
  67.     LOCATE 24,24,1
  68.     LINE INPUT;NewFont$
  69. ReadFont:
  70.     GOSUB ClearFont
  71. 500     OPEN Font$ FOR INPUT AS 1
  72.     CALL    LoadingFont
  73.     LINE INPUT #1,Title$
  74.     LINE INPUT #1,Comment$
  75.     LINE INPUT #1,PrnChar$
  76.     LINE INPUT #1,Margin$
  77.     LINE INPUT #1,Spacing$
  78.     FOR I=1 TO 95
  79.       LINE INPUT #1,CharCode$(I)
  80.     NEXT
  81.     IF NOT EOF(1) THEN
  82.       LINE INPUT #1,Init$
  83.       LINE INPUT #1,Reset$
  84.       INPUT #1,HzMult
  85.       INPUT #1,VMult
  86.       INPUT #1,Vdiv
  87.     END IF
  88.     CLOSE
  89.     IF HzMult=2 THEN
  90.       HzWdth$="Double"
  91.       HColor=12
  92.     ELSEIF HzMult=3 THEN
  93.       HzWdth$="Triple"
  94.       HColor=13
  95.     ELSE
  96.       HzWdth$="Single"
  97.       HzMult=1
  98.       HColor=11
  99.     END IF
  100.     IF VMult=2 THEN
  101.       VWdth$="Double"
  102.       VColor=12
  103.     ELSEIF VMult=3 THEN
  104.       VWdth$="Triple
  105.       VColor=13
  106.     ELSEIF VDiv=2 THEN
  107.       VWdth$="Half  "
  108.       VColor=14
  109.     ELSE
  110.       VWdth$="Single"
  111.       VMult=1
  112.       VDiv=1
  113.       VColor=11
  114.     END IF
  115.     GOSUB FontContents
  116.     CLOSE
  117.     GOTO MainMenu
  118.  
  119.       ELSEIF Opt$="2" THEN    'Option 2. Load a full set of font characters
  120.     CALL    Opt2Prompt
  121.     LOCATE 24,18,1
  122.     LINE INPUT;NewFont$
  123.     GOSUB ClearFont
  124.     GOSUB SetDefaults
  125.     CALL    Opt2Screen
  126.     LOCATE 16,34
  127.     PRINT Font$;" character #";
  128.     FOR Chars=32 TO 126
  129.       LOCATE 16,46+LEN(Font$)
  130.       PRINT Chars;
  131.       GOSUB EncodeChar
  132.     NEXT
  133.     LOCATE 19,22
  134.     PRINT 95-NotUsed;"characters included in ";Font$;
  135.     NotSaved=-1
  136.     GOSUB FontContents
  137.     CALL    Hold
  138.     GOTO MainMenu
  139.  
  140.       ELSEIF Opt$="3" THEN    'Option 3. Open a new font
  141.     CALL    Opt3Screen
  142.     LOCATE 24,13,1
  143.     LINE INPUT;NewFont$
  144.     GOSUB ClearFont
  145.     GOSUB SetDefaults
  146.     GOSUB FontContents
  147.     NotSaved=-1
  148.     GOTO MainMenu
  149.  
  150.       ELSEIF Font$="<none>" AND Opt$>"3" AND Opt$<"9" THEN
  151.     LOCATE 23,1
  152.     COLOR 12,0
  153.     PRINT"A font must be loaded or a new one opened to use option ";Opt$
  154.     COLOR 11,0
  155.     BEEP
  156.     CALL    Hold
  157.     GOTO MainMenu
  158.  
  159.     'Option 4. Load a single font character
  160.       ELSEIF Opt$="4" THEN
  161. LoadChar:
  162.     CALL    Opt4Screen
  163. WhatChar:
  164.     LOCATE 24,1,1
  165.     PRINT"Enter the character you wish to add to ";Font$;" ";
  166.     Char$=INPUT$(1)
  167.     IF Char$<" " OR Char$>"~" THEN
  168.       GOSUB FontContents
  169.       GOTO MainMenu
  170.     ELSE
  171.       PRINT Char$;
  172.     END IF
  173.     Chars=ASC(Char$)
  174.     'define scroll window in assembly values
  175.     ULCorner=&H0800        'row 8 col 0
  176.     LRCorner=&H174F        'row 23 col 79
  177.     CALL    WindowScroll (ULCorner,LRCorner)
  178.     LOCATE 24,1
  179.     PRINT"Adding ";Font$;" character #";Chars;
  180.     GOSUB EncodeChar
  181.     IF NotUsed>0 THEN
  182.       BEEP
  183.       CALL    WindowScroll (ULCorner,LRCorner)
  184.       LOCATE 24,1
  185.       COLOR 12,0
  186.       PRINT"Source file ";CharIn$;" not found";
  187.       COLOR 11,0
  188.     END IF
  189.     CALL    WindowScroll (ULCorner,LRCorner)
  190.     NotUsed=0
  191.     NotSaved=-1
  192.     GOTO WhatChar
  193.  
  194.     'Option 5. Unload a single character to a text file
  195.       ELSEIF Opt$="5" THEN
  196. UnloadChar:
  197.     CALL    Opt5Screen
  198.     'define scroll window in assembly values
  199.     ULCorner=&H0900        'row 9 col 0
  200.     LRCorner=&H174F        'row 23 col 79
  201. UnloadOne:
  202.     LOCATE 24,1,1
  203.     PRINT"Character to unload from ";Font$" : ";
  204.     Char$=INPUT$(1)
  205.     IF Char$<" " OR Char$>"~" THEN
  206.       GOTO MainMenu
  207.     ELSE
  208.       PRINT Char$;
  209.     END IF
  210.     CALL    WindowScroll (ULCorner,LRCorner)
  211.     LOCATE 24,1
  212.     Char=ASC(Char$)
  213.     CH=Char-31
  214.     OutFont$=Font$
  215.     IF CharCode$(CH)<>"" THEN
  216.       PRINT"Unloading character: ";Char;
  217.       GOSUB WriteCharFile
  218.     ELSE
  219.       BEEP
  220.       PRINT"Not Included in ";Font$;
  221.     END IF
  222.     CALL    WindowScroll (ULCorner,LRCorner)
  223.     GOTO UnloadOne
  224.  
  225.     ' Option 6. Unload all of a current font to text files
  226.       ELSEIF Opt$="6" THEN
  227.     CALL    Opt6Screen
  228.     LOCATE 6,42
  229.     PRINT Font$;
  230.     LOCATE 13,36
  231.     PRINT Hght$
  232.     LOCATE 15,36
  233.     COLOR WColor,0
  234.     PRINT Wdth$
  235.     COLOR 11,0
  236.     Done=0
  237.     WHILE NOT Done
  238.       LOCATE 24,34,1
  239.       Opt6$=INPUT$(1)
  240.       IF Opt6$=CHR$(27) OR Opt6$=chr$(3) THEN
  241.         GOTO MainMenu
  242.       ELSEIF Opt6$="1" THEN
  243.         IF HtDiv=2 THEN
  244.           HtDiv=1
  245.           Hght$="Single"
  246.           HtColor=11
  247.         ELSEIF HtMult=1 THEN
  248.           HtMult=2
  249.           Hght$="Double"
  250.           HtColor=12
  251.         ELSEIF HtMult=2 THEN
  252.           HtMult=3
  253.           Hght$="Triple"
  254.           HtColor=13
  255.         ELSEIF HtMult=3 THEN
  256.           HtMult=1
  257.           HtDiv=2
  258.           Hght$="Half  "
  259.           HtColor=14
  260.         END IF
  261.         LOCATE 13,36
  262.         COLOR HtColor,0
  263.         PRINT Hght$
  264.         COLOR 11,0
  265.       ELSEIF Opt6$="2" THEN
  266.         IF WMult=1 THEN
  267.           WMult=2
  268.           Wdth$="Double"
  269.           WColor=12
  270.         ELSEIF WMult=2 THEN
  271.           WMult=3
  272.           Wdth$="Triple"
  273.           WColor=13
  274.         ELSE
  275.           WMult=1
  276.           Wdth$="Single"
  277.           WColor=11
  278.         END IF
  279.         LOCATE 15,36
  280.         COLOR WColor,0
  281.         PRINT Wdth$
  282.         COLOR 11,0
  283.       ELSEIF Opt6$=CHR$(13) THEN
  284.         Done=-1
  285.       END IF
  286.     WEND
  287.     Done=0
  288.     WHILE NOT Done
  289.       IF HtMult<>1 OR WMult<>1 OR HtDiv<>1 THEN
  290.         CALL    ClearToEOS (20)
  291.         LOCATE 24,1
  292.         LINE INPUT;"Output Font Name ? ";OutFont$
  293.         IF OutFont$="" THEN
  294.           GOTO MainMenu
  295.         ELSEIF OutFont$<>Font$ THEN
  296.           Done=-1
  297.         END IF
  298.       ELSE
  299.         OutFont$=Font$
  300.         DONE=-1
  301.       END IF
  302.     WEND
  303.     IF INSTR(OutFont$,".")=0 THEN
  304.       OutFont$=OutFont$+".FNT"
  305.     END IF
  306.     CALL    ClearToEOS (11)
  307.     CALL    Opt6aScreen
  308.     LOCATE 13,42
  309.     PRINT LEFT$(OutFont$,INSTR(OutFont$,"."))
  310.     FOR CH=1 TO 95
  311.       IF CharCode$(CH)<>"" THEN
  312.         Char=CH+31
  313.         LOCATE 20,45
  314.         PRINT Char;
  315.         GOSUB WriteCharFile
  316.       END IF
  317.     NEXT
  318.     PRINT
  319.     GOTO MainMenu
  320.  
  321.       ELSEIF Opt$="7" THEN    'Option 7. Save current font
  322.     CALL    ClearToEOS (13)
  323.     LOCATE 18,20
  324.     PRINT"Save the current font"
  325.     LOCATE 21,1
  326.     FontBak$=LEFT$(Font$,INSTR(Font$,"."))+"BAK"
  327. 1600    OPEN Font$ FOR INPUT AS 1    'See if output font already exists
  328.     CLOSE            'Close, if found, else error trap gets it
  329.     RenameFont=-1
  330. 1700    OPEN FontBak$ FOR INPUT AS 1    'See if <fontname>.BAK exists.
  331.     CLOSE            'Close, if found, else error trap gets it
  332.     PRINT"Erasing  ";FontBak$
  333.     KILL FontBak$
  334. NewBakFile:
  335.     IF RenameFont THEN
  336.       PRINT"Changing ";Font$;" to ";FontBak$
  337.       NAME Font$ AS FontBak$
  338.     END IF
  339.     PRINT"Writing  ";Font$
  340.     OPEN Font$ FOR OUTPUT AS 1
  341.     PRINT #1,Title$
  342.     PRINT #1,Comment$
  343.     PRINT #1,PrnChar$
  344.     PRINT #1,Margin$
  345.     PRINT #1,Spacing$
  346.     FOR J=1 TO 95
  347.       PRINT #1,CharCode$(J)
  348.     NEXT
  349.     PRINT #1,Init$
  350.     PRINT #1,Reset$
  351.     PRINT #1,HzMult
  352.     PRINT #1,VMult
  353.     PRINT #1,Vdiv
  354.     CLOSE
  355.     NotSaved=0
  356.     CALL    Hold
  357.     GOTO MainMenu
  358.  
  359.       ELSEIF Opt$="8" THEN    'Option 8. Change font defaults
  360.     GOSUB SetDefaults
  361.     NotSaved=-1
  362.     GOTO MainMenu
  363.  
  364.       ELSEIF Opt$="9" THEN    'Option 9. Modify font text files
  365. OptIn9:
  366.     NumFiles=0
  367.     CALL    Opt9Screen
  368.     LOCATE 18,27,1
  369. GetOpt9:
  370.     Opt9$=INPUT$(1)
  371.     IF Opt9$=CHR$(3) OR Opt9$=CHR$(27) THEN
  372.       GOTO MainMenu
  373.     ELSEIF Opt9$<"1" OR Opt9$>"6" THEN
  374.       BEEP
  375.       GOTO GetOpt9
  376.     END IF
  377.     PRINT Opt9$;
  378.     CALL    InFilePrompt
  379.     LOCATE 20,39
  380.     LINE INPUT CharIn$
  381.     IF CharIn$="" THEN
  382.       GOTO OptIn9
  383.     END IF
  384.     CALL    OutFilePrompt
  385.     LOCATE 22,40
  386.     LINE INPUT CharOut$
  387.     IF CharOut$="" THEN
  388.       GOTO OptIn9
  389.     ELSEIF CharOut$=CharIn$ THEN
  390.       BEEP
  391.       CALL    InEquOut
  392.       CALL    Hold
  393.       GOTO OptIn9
  394.     END IF
  395.  
  396.     IF OPT9$<"4" THEN
  397. 2400      OPEN CharOut$ FOR INPUT AS 1
  398.       CLOSE
  399.       CALL    OvrWrtPrmpt
  400.       LOCATE 24,31,1
  401.       Ans$=INPUT$(1)
  402.       IF LEFT$(Ans$,1)<>"Y" AND LEFT$(Ans$,1)<>"y" THEN
  403.         GOTO OptIn9
  404.       END IF
  405. NoOutFile:
  406.       StartLine=19
  407.       CALL    ClearToEOS (StartLine)
  408.       LOCATE 20,1
  409.       PRINT"Reading ";CharIn$
  410.       GOSUB ReadInputChar
  411.       IF SkipFlag THEN
  412.         BEEP
  413.         COLOR 12,0
  414.         LOCATE 20,1
  415.         PRINT CharIn$;" not found"
  416.         COLOR 11,0
  417.         CALL    Hold
  418.         SkipFlag=0
  419.         GOTO OptIn9
  420.       END IF
  421.       LOCATE 22,1
  422.       PRINT"Writing ";CharOut$
  423.  
  424.     ELSE
  425.       IF INSTR(CharIn$,".")=0 THEN
  426.         CharIn$=CharIn$+"."
  427.       END IF
  428.       IF INSTR(CharOut$,".")=0 THEN
  429.         CharOut$=CharOut$+"."
  430.       END IF
  431.       IF LEFT$(CharIn$,INSTR(CharIn$,"."))=_
  432.           LEFT$(CharOut$,INSTR(CharOut$,".")) THEN
  433.         BEEP
  434.         CALL    InEquOut
  435.         CALL    Hold
  436.         GOTO OptIn9
  437.       END IF
  438.       StartLine=19
  439.       CALL    ClearToEOS (StartLine)
  440.       LOCATE 20,21
  441.       PRINT"Working on :";
  442.       FOR CH=1 TO 95
  443.         Char=CH+31
  444.         Ext$=MID$(STR$(Char),2)
  445.         IF LEN(Ext$)=2 THEN
  446.           Ext$="0"+Ext$
  447.         END IF
  448.         CharIn$=LEFT$(CharIn$,INSTR(CharIn$,"."))+Ext$
  449.         CharOut$=LEFT$(CharOut$,INSTR(CharOut$,"."))+Ext$
  450. 3000        OPEN CharOut$ FOR INPUT AS 1
  451.         CLOSE
  452.         BEEP
  453.         CALL    OvrWrtPrmpt
  454.         LOCATE 24,31,1
  455.         Ans$=INPUT$(1)
  456.         IF LEFT$(Ans$,1)<>"Y" AND LEFT$(Ans$,1)<>"y" THEN
  457.           GOTO Skipchar
  458.         END IF
  459. NoOldFile:
  460.         LOCATE 20,34
  461.         PRINT CharIn$;" ===> ";CharOut$;
  462.         GOSUB ReadInputChar
  463.         IF NOT SkipFlag THEN
  464.           IF Opt9$="4" THEN
  465.         GOSUB Rotate180
  466.           ELSEIF Opt9$="5" THEN
  467.         GOSUB Rotate90
  468.           ELSEIF Opt9$="6" THEN
  469.         GOSUB FlipFile
  470.           END IF
  471.         ELSE
  472.           SkipFlag=0
  473.         END IF
  474. SkipChar:
  475.         Quit$=INKEY$
  476.         IF Quit$<>"" THEN
  477.           GOSUB BailOut
  478.         END IF
  479.       NEXT
  480.       IF Numfiles=0 THEN
  481.         COLOR 12,0
  482.         LOCATE 22,28
  483.         PRINT"No source files located"
  484.         BEEP
  485.         COLOR 11,0
  486.       ELSE
  487.         LOCATE 22,30
  488.         PRINT Numfiles;" Files created."
  489.       END IF
  490.     END IF
  491.  
  492.     IF Opt9$="1" THEN
  493.       GOSUB Rotate180
  494.  
  495.     ELSEIF Opt9$="2" THEN
  496.       GOSUB Rotate90
  497.  
  498.     ELSEIF Opt9$="3" THEN
  499.       GOSUB FlipFile
  500.     END IF
  501.     CALL    Hold
  502.     GOTO OptIn9
  503.  
  504.       ELSEIF Opt$=CHR$(27) OR Opt$=CHR$(3) THEN    ' <Esc> to Exit
  505.     IF NotSaved THEN
  506.       StartLine=22
  507.       CALL    ClearToEOS (StartLine)
  508.       LOCATE 24,1,1
  509.       PRINT"Abandon modified font: ";Font$;" (Y/N) ? ";
  510.       Ans$=INPUT$(1)
  511.       IF Ans$<>"Y" AND Ans$<>"y" THEN
  512.         GOTO MainMenu
  513.       END IF
  514.     END IF
  515.     GOTO Finish
  516.  
  517.       END IF
  518.       GOTO GetOption
  519.  
  520. Finish:
  521.       CLS
  522.       END
  523.  
  524. ReadInputChar:
  525. 4000  OPEN CharIn$ FOR INPUT AS 1
  526.       OPEN CharOut$ FOR OUTPUT AS 2
  527.       NumFiles=Numfiles+1
  528.       FOR I=1 TO 200
  529.     Lin$(I)=""
  530.       NEXT
  531.       Row=0
  532.       MaxLen=0
  533.       FOR I=1 TO 200
  534.     LIN$(I)=""
  535.       NEXT
  536.       DONE=0
  537.       WHILE NOT Done
  538.     Row=Row+1
  539.     LINE INPUT #1,LIN$(Row)
  540.     IF LEN(Lin$(Row))>MaxLen THEN
  541.       MaxLen=LEN(LIN$(Row))
  542.     END IF
  543.     IF Row=200 OR EOF(1) THEN
  544.       DONE=-1
  545.     END IF
  546.       WEND
  547.       CLOSE #1
  548. NoChar:
  549.       RETURN
  550.  
  551. Rotate180:    'Option 9.1 & 9.4 write 180 degree rotated file
  552.       FOR I=1 TO Row
  553.     Lin$(I)=Lin$(I)+STRING$(MaxLen-LEN(Lin$(I)),32)
  554.       NEXT
  555.       FOR I=Row TO 1 STEP -1
  556.     FOR K=1 TO LEN(Lin$(I))
  557.       IF MID$(LIN$(I),K,1)<> " " THEN
  558.         Blank=K
  559.         K=LEN(Lin$(I))
  560.       END IF
  561.     NEXT
  562.     FOR J=LEN(Lin$(I)) TO 1 STEP -1
  563.       Temp$=Temp$+MID$(Lin$(I),J,1)
  564.     NEXT
  565.     Temp$=LEFT$(Temp$,LEN(Temp$)-(Blank-1))
  566.     PRINT #2,Temp$
  567.     Temp$=""
  568.       NEXT
  569.       CLOSE
  570.       RETURN
  571.  
  572. Rotate90:    'Option 9.2 & 9.5 write file rotated 90 degrees clockwise
  573.       FOR I=1 TO 200
  574.     Lin90$(I)=""
  575.       NEXT
  576.       ChrStart=0
  577.       FOR I=Row TO 1 STEP -1
  578.     FOR K=1 TO MaxLen
  579.       IF LEN(Lin$(I))<K THEN
  580.         Lin90$(K)=Lin90$(K)+" "
  581.       ELSE
  582.         Lin90$(K)=Lin90$(K)+MID$(Lin$(I),K,1)
  583.       END IF
  584.     NEXT
  585.       NEXT
  586.       FOR I=1 TO MaxLen
  587.     IF NOT ChrStart THEN
  588.       IF Lin90$(I) <> STRING$(LEN(lin90$(I)),32) THEN
  589.         ChrStart=-1
  590.       END IF
  591.     END IF
  592.     IF ChrStart THEN
  593.       FOR J=LEN(Lin90$(I)) TO 1 STEP -1
  594.         IF MID$(Lin90$(I),J,1)<>" " THEN
  595.           StringEnd=J
  596.           J=1
  597.         END IF
  598.       NEXT
  599.       PRINT #2,LEFT$(Lin90$(I),StringEnd)
  600.     END IF
  601.       NEXT
  602.       CLOSE
  603.       RETURN
  604.  
  605. FlipFile:    'Option 9.3 & 9.6 write inverted line order file
  606.       FOR I=Row TO 1 STEP -1
  607.     PRINT #2,Lin$(I)
  608.       NEXT
  609.       CLOSE
  610.       RETURN
  611.  
  612. FontContents:
  613.       FontContent$=""
  614.       FOR I=1 TO 95
  615.     IF I=1 AND CharCode$(I)<>"" THEN
  616.       FontContent$="space "
  617.     ELSEIF CharCode$(I)<>"" THEN
  618.       FontContent$=FontContent$+CHR$(I+31)+" "
  619.     END IF
  620.       NEXT
  621.       RETURN
  622.  
  623. EncodeChar:    'Encode character text file subroutine
  624.       TMP$=""
  625.       Extension$=MID$(STR$(Chars),2)
  626.       IF LEN(Extension$)<3 THEN
  627.     Extension$="0"+Extension$
  628.       END IF
  629.       CharIn$=LEFT$(Font$,INSTR(Font$,"."))+Extension$
  630.       Quit$=INKEY$
  631.       IF Quit$<>"" THEN
  632.     GOSUB BailOut
  633.       END IF
  634. 5000  OPEN CharIn$ FOR INPUT AS 2
  635.       FOR Lines=1 TO 200
  636.     LINE INPUT #2,Txt$
  637.     COL=0:SEGLEN=0
  638.     FOR Char=LEN(Txt$) TO 1 STEP -1
  639.       IF MID$(Txt$,Char,1)<>" "AND MID$(Txt$,Char,1)<>CHR$(9) THEN
  640.         GOTO CharLoop
  641.       END IF
  642.     NEXT
  643.     Tmp$=Tmp$+CHR$(255)    ' found a blank line
  644.     GOTO EofCheck
  645. CharLoop:
  646.     FOR Byte=1 TO Char
  647.       IF SEGLEN=95 THEN
  648.         Tmp$=Tmp$+CHR$(127)
  649.         SEGLEN=0
  650.       END IF
  651.       Byte$=MID$(Txt$,Byte,1)
  652.       IF Byte$=CHR$(9) THEN
  653.         Col=Col+8-(Col MOD 8)
  654.       ELSE
  655.         Col=Col+1
  656.       END IF
  657.       IF SegLen=0 THEN
  658.         IF Byte$<>" " AND Byte$<>CHR$(9) THEN
  659.           Tmp$=Tmp$+CHR$(Col+31)
  660.         END IF
  661.       END IF
  662.       IF Byte$<>" " AND Byte$<>CHR$(9) THEN
  663.         SegLen=SegLen+1
  664.       END IF
  665.       IF SegLen<>0 THEN
  666.         IF Byte$=" " OR Byte$=CHR$(9) THEN
  667.           Tmp$=Tmp$+CHR$(SegLen+32)
  668.           SegLen=0
  669.         END IF
  670.       END IF
  671.     NEXT
  672.     Tmp$=Tmp$+CHR$(SegLen+160)
  673. EofCheck:
  674.     IF EOF(2) THEN
  675.       GOTO LoadArrayElement
  676.     END IF
  677.       NEXT
  678. LoadArrayElement:
  679.       CharCode$(Chars-31)=Tmp$
  680. DoNextChar:
  681.       CLOSE
  682.       RETURN
  683.  
  684. ClearFont:    'New font subroutine
  685.       IF NewFont$<>CHR$(255) THEN
  686.     IF NewFont$="" THEN
  687.       GOTO MainMenu
  688.     ELSEIF NotSaved THEN
  689.       StartLine=22
  690.       CALL    ClearToEOS (StartLine)
  691.       LOCATE 24,1,1
  692.       PRINT"Abandon modified font: ";Font$;" (Y/N) ? ";
  693.       Ans$=INPUT$(1)
  694.       IF Ans$<>"Y" AND Ans$<>"y" THEN
  695.         GOTO MainMenu
  696.       END IF
  697.     END IF
  698.     IF INSTR(NewFont$,".")=0 THEN
  699.       NewFont$=NewFont$ + ".FNT"
  700.     END IF
  701.     Font$=NewFont$
  702.       ELSE
  703.     Font$="<none>"
  704.       END IF
  705.       Title$=""
  706.       Comment$=""
  707.       PrnChar$=""
  708.       Margin$=""
  709.       Spacing$=""
  710.       FOR I=1 TO 95
  711.     CharCode$(I)=""
  712.       NEXT
  713.       NotSaved=0
  714.       RETURN
  715.  
  716. BailOut:    'Quit current function subroutine
  717.       IF Quit$=CHR$(27) OR Quit$=CHR$(3) THEN
  718.     CLOSE
  719.     BEEP
  720.     CALL    Abort
  721.     CALL    Hold
  722.     GOTO MainMenu
  723.       END IF
  724.       RETURN
  725.  
  726. WriteCharFile:    'Write large character text file subroutine
  727.       CodeLen=LEN(CharCode$(CH))
  728.       IF CodeLen<>0 THEN
  729.     Ext$=MID$(STR$(Char),2)
  730.     IF LEN(Ext$)=2 THEN
  731.       Ext$="0"+Ext$
  732.     END IF
  733.     CharOut$=LEFT$(OutFont$,INSTR(OutFont$,"."))+Ext$
  734.     OPEN CharOut$ FOR OUTPUT AS 1
  735.     FOR Byte=1 TO CodeLen STEP 2
  736.       LineFlag=0
  737.       IF MID$(CharCode$(CH),Byte,1)=CHR$(255) THEN
  738.         FOR I=1 TO WMult
  739.           PRINT #1,""
  740.         NEXT
  741.         Byte=Byte-1
  742.       ELSE
  743.         Segment=Segment+1
  744.         Column=ASC(MID$(CharCode$(CH),Byte,1))-31
  745.         Length=ASC(MID$(CharCode$(CH),Byte+1,1))
  746.         IF Length>127 THEN
  747.           Length=Length-128
  748.           LineFlag=-1
  749.         END IF
  750.         Length=Length-32
  751.         PRINT #1,TAB((Column*HtMult)/HtDiv)_
  752.             STRING$((Length*HtMult)/HtDiv,PrnChar$);
  753.         IF LineFlag THEN
  754.           PRINT #1,""
  755.           NumRows=NumRows+1
  756.           IF NumRows<WMult THEN
  757.         Byte=Byte-(Segment*2)
  758.           ELSE
  759.         NumRows=0
  760.           END IF
  761.           Segment=0
  762.         END IF
  763.       END IF
  764.     NEXT
  765.     CLOSE #1
  766.     Quit$=INKEY$
  767.     IF Quit$<>"" THEN
  768.       GOSUB BailOut
  769.     END IF
  770.       END IF
  771.       RETURN
  772.  
  773. SetDefaults:    'Set font defaults subroutine
  774.       CALL    SetDef1Screen
  775.       LOCATE 7,5
  776.       PRINT Title$
  777.       LOCATE 24,9,1
  778.       LINE INPUT;Temp$
  779.       IF Temp$="" AND Title$="" OR LEN(Temp$)>70 THEN
  780.     BEEP
  781.     GOTO SetDefaults
  782.       END IF
  783.       IF Temp$<>"" THEN
  784.     Title$=Temp$
  785.       END IF
  786.  
  787. EnterComment:
  788.       CALL    SetDef2Screen
  789.       LOCATE 7,5
  790.       PRINT Comment$
  791.       LOCATE 24,11,1
  792.       LINE INPUT;Temp$
  793.       IF LEN(Temp$)>70 THEN
  794.     BEEP
  795.     GOTO EnterComment
  796.       ELSEIF Temp$="999" THEN
  797.     Comment$=""
  798.       ELSEIF Temp$<>"" THEN
  799.     Comment$=Temp$
  800.       END IF
  801.  
  802. PrintChar:
  803.       CALL    SetDef3Screen
  804.       IF PrnChar$="" THEN
  805.     PrnChar$="@"
  806.       END IF
  807.       LOCATE 7,37
  808.       IF PrnChar$=CHR$(255) THEN
  809.       PRINT" Variable"
  810.       ELSEIF PrnChar$<"!" OR PrnChar$>"~" THEN
  811.     PRINT ASC(PrnChar$);"Decimal";
  812.       ELSE
  813.     PRINT" ";PrnChar$;" -";ASC(PrnChar$);"Decimal";
  814.       END IF
  815.       LOCATE 24,31,1
  816.       LINE INPUT;NewPrnChar$
  817.       IF LEN(NewPrnChar$)>1 THEN
  818.     FOR I=1 TO LEN(NewPrnChar$)
  819.       IF MID$(NewPrnChar$,I,1)<"0" OR MID$(NewPrnChar$,I,1)>"9" THEN
  820.         BEEP
  821.         GOTO PrintChar
  822.       END IF
  823.     NEXT
  824.     IF VAL(NewPrnChar$)>255 THEN
  825.       BEEP
  826.       GOTO PrintChar
  827.     ELSE
  828.       PrnChar$=CHR$(VAL(NewPrnChar$))
  829.     END IF
  830.       ELSEIF NewPrnChar$<>"" THEN
  831.     PrnChar$=NewPrnChar$
  832.       END IF
  833.  
  834. SetMargin:
  835.       CALL    SetDef4Screen
  836.       IF Margin$="" THEN
  837.     Margin$="1"
  838.       END IF
  839.       LOCATE 7,40
  840.       PRINT Margin$
  841.       LOCATE 24,28,1
  842.       LINE INPUT;NewMargin$
  843.       FOR I=1 TO LEN(NewMargin$)
  844.     IF MID$(NewMargin$,I,1)<"0" OR MID$(NewMargin$,I,1)>"9" THEN
  845.       BEEP
  846.       GOTO SetMargin
  847.     END IF
  848.       NEXT
  849.       IF VAL(NewMargin$)>230 THEN
  850.     BEEP
  851.     GOTO SetMargin
  852.       END IF
  853.       IF NewMargin$<>"" THEN
  854.     Margin$=NewMargin$
  855.       END IF
  856.  
  857. SetSpacing:
  858.       CALL    SetDef5Screen
  859.       IF Spacing$="" THEN
  860.     Spacing$="3"
  861.       END IF
  862.       LOCATE 7,40
  863.       PRINT Spacing$
  864.       LOCATE 24,18,1
  865.       LINE INPUT;NewSpacing$
  866.       IF LEN(NewSpacing$)>2 THEN
  867.     BEEP
  868.     GOTO SetSpacing
  869.       END IF
  870.       FOR I=1 TO LEN(NewSpacing$)
  871.     IF MID$(NewSpacing$,I,1)<"0" OR MID$(NewSpacing$,I,1)>"9" THEN
  872.       BEEP
  873.       GOTO SetSpacing
  874.     END IF
  875.       NEXT
  876.       IF NewSpacing$<>"" THEN
  877.     Spacing$=NewSpacing$
  878.       END IF
  879.  
  880.     'Set printer initialization & reset strings
  881.       CALL    SetDef6Screen
  882.       GOSUB InitSet
  883.       IF Dec$="999" THEN
  884.     Init$=""
  885.     NotSaved=-1
  886.       ELSEIF PrnInit$<>"" THEN
  887.     Init$=PrnInit$
  888.     NotSaved=-1
  889.       END IF
  890.       CALL    SetDef7Screen
  891.       GOSUB InitSet
  892.       IF Dec$="999" THEN
  893.     Reset$=""
  894.     NotSaved=-1
  895.       ELSEIF PrnInit$<>"" THEN
  896.     Reset$=PrnInit$
  897.     NotSaved=-1
  898.       END IF
  899.  
  900.     'Set horizontal & vertical magnification factors
  901.       CALL    SetDef8Screen
  902.       LOCATE 24,15,1
  903.       IF HzMult=0 THEN
  904.     HzWdth$="Single"
  905.     HzMult=1
  906.     HColor=11
  907.     VWdth$="Single"
  908.     VColor=11
  909.     Vdiv=1
  910.     VMult=1
  911.       END IF
  912.       DONE=0
  913.       WHILE NOT Done
  914.     LOCATE 16,53
  915.     COLOR HColor,0
  916.     PRINT HzWdth$;
  917.     LOCATE 19,53
  918.     COLOR VColor,0
  919.     PRINT VWdth$;
  920.     COLOR 11,0
  921.     LOCATE 24,22,1
  922.     Temp$=INPUT$(1)
  923.     IF Temp$=CHR$(13) THEN
  924.       DONE=-1
  925.     ELSEIF Temp$="1" THEN
  926.       IF HzMult=3 THEN
  927.         HzWdth$="Single"
  928.         HzMult=1
  929.         HColor=11
  930.       ELSEIF HzMult=1 THEN
  931.         HzWdth$="Double"
  932.         HzMult=2
  933.         HColor=12
  934.       ELSE
  935.         HzWdth$="Triple"
  936.         HzMult=3
  937.         HColor=13
  938.       END IF
  939.     ELSEIF Temp$="2" THEN
  940.       IF VDiv=2 THEN
  941.         VWdth$="Single"
  942.         VColor=11
  943.         Vdiv=1
  944.       ELSEIF VMult=1 THEN
  945.         VWdth$="Double"
  946.         VMult=2
  947.         VColor=12
  948.       ELSEIF VMult=2 THEN
  949.         VWdth$="Triple"
  950.         VMult=3
  951.         VColor=13
  952.       ELSE
  953.         VWdth$="Half  "
  954.         VMult=1
  955.         VDiv=2
  956.         VColor=14
  957.       END IF
  958.     ELSE
  959.       BEEP
  960.     END IF
  961.       WEND
  962.       RETURN
  963.  
  964. InitSet:    'Enter printer initialization or reset strings
  965.       K=0
  966.       LOCATE 16,1
  967.       PrnInit$=""
  968.       Dec$="0"
  969.       WHILE Dec$<>""
  970.     BadVal=0
  971.     K=K+1
  972.     PRINT"Decimal value for byte #";K;": ";
  973.     LINE INPUT Dec$
  974.     IF LEN(Dec$)>3 THEN
  975.       BEEP
  976.       BadVal=-1
  977.       K=K-1
  978.     ELSEIF Dec$<>"" THEN
  979.       FOR J=1 TO LEN(Dec$)
  980.         IF MID$(Dec$,J,1)<"0" OR MID$(Dec$,J,1)>"9" THEN
  981.           BEEP
  982.           J=LEN(Dec$)
  983.           BadVal=-1
  984.           K=K-1
  985.         END IF
  986.       NEXT
  987.       IF Dec$="999" THEN
  988.         PrnInit$=""
  989.       ELSEIF VAL(Dec$)>255 THEN
  990.         BEEP
  991.         K=K-1
  992.       ELSEIF NOT BadVal THEN
  993.         PrnInit$=PrnInit$+CHR$(VAL(Dec$))
  994.       END IF
  995.     END IF
  996.       WEND
  997.       RETURN
  998.  
  999. ErrorHandle:
  1000.       IF ERR=53 AND ERL=5000 THEN
  1001.     NotUsed=NotUsed+1
  1002.     IF NotUsed=95 THEN
  1003.       COLOR 12,0
  1004.       CALL    NoFiles
  1005.       LOCATE 4,39
  1006.       PRINT Font$;"!";
  1007.       NotSaved=0
  1008.     ELSE
  1009.       RESUME DoNextChar        'encode character subroutine
  1010.     END IF
  1011.       ELSEIF ERR=53 AND ERL=1600 THEN
  1012.     CLOSE
  1013.     RESUME 1700
  1014.       ELSEIF ERR=53 AND ERL=1700 THEN
  1015.     CLOSE
  1016.     RESUME NewBakFile
  1017.       ELSEIF ERR=53 AND ERL=2400 THEN
  1018.     CLOSE
  1019.     RESUME NoOutFile
  1020.       ELSEIF ERR=53 AND ERL=500 OR ERR=76 AND ERL=500 THEN
  1021.     CLOSE
  1022.     LOCATE 23,1
  1023.     COLOR 12,0
  1024.     PRINT"Encoded font ";Font$;" not found.";
  1025.       ELSEIF ERR=53 AND ERL=3000 THEN
  1026.     CLOSE
  1027.     RESUME NoOldFile
  1028.       ELSEIF ERL=4000 THEN
  1029.     SkipFlag=-1
  1030.     RESUME NoChar
  1031.       ELSEIF ERL=2400 THEN
  1032.     IF ERR=52 OR ERR=64 OR ERR=75 OR ERR=76 THEN
  1033.       COLOR 12,0
  1034.       PRINT"Bad Filename or Path"
  1035.       COLOR 11,0
  1036.       BEEP
  1037.       CALL    Hold
  1038.       RESUME OptIn9
  1039.     END IF
  1040.       ELSEIF ERR=52 OR ERR=64 OR ERR=75 OR ERR=76 THEN
  1041.     CLS
  1042.     CALL    MenuScreen
  1043.     LOCATE 23,1
  1044.     COLOR 12,0
  1045.     PRINT"Bad font name or path";
  1046.       ELSE
  1047.     ON ERROR GOTO 0
  1048.       END IF
  1049.       BEEP
  1050.       COLOR 11,0
  1051.       CALL    Hold
  1052.       NewFont$=CHR$(255)
  1053.       GOSUB ClearFont
  1054.       RESUME MainMenu
  1055.